home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Listbox.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  3.8 KB  |  162 lines
  1. ;;;;
  2. ;;;; L i s t b o x . s t k         --  Listbox class definition
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  15. ;;;;    Creation date: 28-Feb-1994 14:38
  16. ;;;; Last file update:  2-Aug-1995 12:39
  17.  
  18. (require "Basics")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; <Listbox> class
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (define-class <Listbox> (<Tk-simple-widget> <Tk-selectable> <Tk-sizeable>
  27.              <Tk-text-selectable> <Tk-xyscrollable>)
  28.   ((set-grid        :init-keyword :set-grid
  29.                :accessor     set-grid
  30.             :tk-name      setgrid
  31.             :allocation   :tk-virtual)
  32.    (select-mode        :init-keyword :select-mode
  33.             :accessor     select-mode
  34.             :tk-name      selectm
  35.             :allocation   :tk-virtual)
  36.    ;; Fictive slot 
  37.    (value        :accessor     value
  38.             :init-keyword :value
  39.             :allocation   :virtual
  40.             :slot-ref     (lambda (o)
  41.                     ((Id o) 'get 0 'end))
  42.             :slot-set!    (lambda (o v)
  43.                     (let ((w  (Id o)))
  44.                       (w 'delete 0 'end)
  45.                       (apply w 'insert 0 v))))))
  46.  
  47. (define-method tk-constructor ((self <Listbox>))
  48.   Tk:listbox)
  49.  
  50. ;;;
  51. ;;; Listbox-activate
  52. ;;;
  53. (define-method  listbox-activate ((self <Listbox>) index)
  54.   ((slot-ref self 'Id) 'activate index))
  55.  
  56. ;;;
  57. ;;; Bounding-box
  58. ;;;
  59. (define-method bounding-box ((self <Listbox>) index)
  60.   ((slot-ref self 'Id) 'bbox index))
  61.  
  62. ;;;
  63. ;;; Current-selection
  64. ;;;
  65. (define-method current-selection ((self <Listbox>))
  66.   (let ((res ((slot-ref self 'Id) 'curselection)))
  67.     (if (null? res) #f res)))
  68.  
  69. ;;;
  70. ;;; Delete
  71. ;;; 
  72. (define-method delete ((self <Listbox>) start . end)
  73.   (apply (slot-ref self 'Id) 'delete start end))
  74.  
  75. ;;;
  76. ;;; Get
  77. ;;;
  78. (define-method get ((self <Listbox>) start . end)
  79.   (apply (slot-ref self 'Id) 'get start end))
  80.  
  81. ;;;
  82. ;;; Index
  83. ;;;
  84. (define-method listbox-index ((self <Listbox>) index)
  85.   ((slot-ref self 'Id) 'index index))
  86.  
  87. ;;;
  88. ;;; Insert
  89. ;;;
  90. (define-method insert ((self <Listbox>) index . value)
  91.   (apply (slot-ref self 'Id) 'insert index value))
  92.  
  93. ;;;
  94. ;;; Nearest
  95. ;;; 
  96. (define-method nearest ((self <Listbox>) index)
  97.   ((slot-ref self 'Id) 'nearest index))
  98.  
  99.  
  100. ;;;
  101. ;;; Mark 
  102. ;;; 
  103. (define-method text-mark ((self <Listbox>) x y)
  104.   ((slot-ref self 'Id) 'scan 'mark x y))
  105.  
  106. ;;;
  107. ;;; Drag-to 
  108. ;;; 
  109. (define-method text-drag-to ((self <Listbox>) x y)
  110.   ((slot-ref self 'Id) 'scan 'dragto x y))
  111.  
  112. ;;;
  113. ;;; See-item
  114. ;;;
  115. (define-method see-item ((self <Listbox>) index)
  116.   ((slot-ref self 'Id) 'see index))
  117.  
  118. ;;;
  119. ;;; Selection-anchor
  120. ;;; 
  121. (define-method selection-anchor ((self <Listbox>) index)
  122.   ((slot-ref self 'Id) 'selection 'anchor index))
  123.  
  124. ;;;
  125. ;;; Selection-clear
  126. ;;; 
  127. (define-method selection-clear ((self <Listbox>) first . last)
  128.   (apply (slot-ref self 'Id) 'selection 'clear first last))
  129.  
  130. ;;;
  131. ;;; Selection-includes
  132. ;;; 
  133. (define-method selection-includes ((self <Listbox>) index)
  134.   ((slot-ref self 'Id) 'selection 'includes index))
  135.  
  136. ;;;
  137. ;;; Selection-set
  138. ;;; 
  139. (define-method selection-set ((self <Listbox>) first . last)
  140.   (apply (slot-ref self 'Id) 'selection 'set first last))
  141.  
  142. ;;;
  143. ;;; Size
  144. ;;; 
  145. (define-method size ((self <Listbox>))
  146.   ((slot-ref self 'Id) 'size))
  147.  
  148. ;;;
  149. ;;; X-View
  150. ;;; 
  151. (define-method x-view ((self <Listbox>) . args)
  152.   (apply (slot-ref self 'Id) 'xview args))
  153.  
  154. ;;;
  155. ;;; Y-View
  156. ;;; 
  157. (define-method y-view ((self <Listbox>) args)
  158.   (apply (slot-ref self 'Id) 'yview args))
  159.  
  160.  
  161. (provide "Listbox")
  162.